home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / System source / Window < prev   
Text File  |  1993-06-04  |  9KB  |  286 lines
  1. \  5/07/84  NDI Version 1
  2. \  9/05/84  CBD Version 1.3
  3. \  9/07/84  CBD Fixed GetVRect:
  4. \ 11/22/84  cbd ctlHit, fixed drag:, grow:
  5. \ 12/08/85  cdn Modified enable: & disable: to flip-flop Null-Evt vectors
  6. \ 12/15/85  cdn Moved FinalSave to Util module
  7. \  4/15/86    cdn    Added Hide: method
  8. \  5/27/86  cdn Added idle vector; enable:/disable now set actW (active window)
  9. \  8/07/86  cdn Added deact vector & setact:
  10. \  8/12/86  cdn Removed extraneous drops in new:
  11. \ 12/26/87    rfl    could modify draw: to not set, but to set super to save fprect
  12. \ 11/06/90    rfl    example: now uses grayRgn for drag; simplified classinit
  13. \ 11/23/90    rfl    added grayRgn word
  14. \  3/22/91    rfl    because of complaints, growbox now erased on grow
  15. \  4/09/91    rfl    also, grow now computes to send next line to bottom if necessary
  16. \  4/29/91    rfl simplified eraseGrow:...but did not recompile source
  17. \ 10/21/91    rfl    added a lot of Michael Hore's window routines, grow box support, etc.
  18. \                moved screenbits from objinit
  19. \ 12/18/91    rfl    resID now stored with object, getnew: requires nothing on stack
  20. \ 12/27/91    rfl    drag no longer selects window...command key option works as in IM
  21. \  6/22/92    rfl    erasegrow: only works if grow flag is set
  22. \  9/28/92    rfl    added portBit:
  23. \ 10/18/92    rfl added 'part' as parameter for zoom handler...Used to have to use
  24. \                 mp2 to get zoom state from methods stack
  25. \  5/10/93    rfl    shortened getnew: and check for resource with error message
  26. \  5/29/93    rfl removed theWindow; changed thePort to myPort.
  27. Decimal
  28.  
  29.  -1  Constant  inFront
  30.   0  Variable  myPort
  31. 129  Constant  Thumb
  32.  
  33.   0  Constant  docWind
  34.  16  Constant  rndWind
  35.   1  Constant  dlgWind
  36.  
  37. : initFont  9 tsize 4 tfont 0 tMode 0 tFace  ;
  38. : grayRgn ( -- l t r b ) $ 9ee -base @ >ptr 2+ get: rect ;
  39.  
  40. \ ( b -- bool )  make a Forth boolean into a Toolbox boolean
  41. : Bool   8 << makeInt  ;
  42.  
  43. \ save and restore the GrafPort
  44. : savePort   myPort +base call GetPort ;
  45. : restPort   myPort @  call SetPort ;
  46.  
  47. \ ( -- l t r b )  leave dimension coordinates of host machine's display
  48. : ScreenBits
  49.     $ 904 -base @ -base @ -base 116 -
  50.     dup    @ unpack
  51.     rot 4+ @ unpack
  52. ;
  53.  
  54. \ define the basic Window class, which has no controls
  55. :CLASS Window  <Super GrafPort
  56.  
  57.     $ 20 Bytes    wind1    \ unmapped
  58.     Handle        Ctllist    \ 1st ctl
  59.     $ 0C Bytes    wind2    \ unmapped
  60.  
  61.     Rect    contRect    \ true content
  62.     Rect    growRect    \ grow size rectangle
  63.     Rect    dragRect    \ Drag limits rect
  64.     Int        growFlg        \ true if growable
  65.     Int        dragFlg        \ true if draggable
  66.     Int        Alive        \ true if space exists
  67.     Var        Idle        \ cfa- idle handler
  68.     Var        Deact        \ cfa- deactivate event handler
  69.  
  70.     Var        Content        \ cfa- content handler
  71.     Var        Draw        \ cfa- draw handler
  72.     Var        Enact        \ cfa- activate event handler
  73.     Var        Close        \ cfa- close handler
  74.     Int        Resid        \ Resource ID
  75.     int        scrollFlg    \ flag to not update fprect for scrolling
  76.     Var        Zoom        \ cfa- zoom word
  77.  
  78. \ set drag and grow limits based on multiple screen regions
  79.     :M  SETLIMITS: grayRgn put: dragRect
  80.         40 40 getBot: dragRect put: growRect
  81.         4 4 inset: dragRect true put: dragFlg true put: growFlg ;M
  82.  
  83.     :M  SETZOOM: put: Zoom ;M
  84.  
  85.     :M  SETSCROLL: put: scrollFlg ;M
  86.  
  87.     :M  SETFPRECT: get: scrollFlg IF get: contRect put: fPrect THEN ;M
  88.  
  89.     \ ( -- )  update the Forth output, scrolling rects
  90.     :M  SETVIEW: get: portRect get: growFlg
  91.         IF swap 15 - swap 15 - THEN  put: contRect
  92.         setfPrect: self ;M
  93.  
  94.     \ ( n --)
  95.     :M  PUTRESID: put: resID ;M
  96.     \ ( -- )
  97.     :M  CLOSE:  get: alive
  98.         IF (abs) call CloseWindow clear: alive  exec: close
  99.         THEN  ;M
  100.  
  101.     \ ( -- )  Make this wind the current GrafPort
  102.     :M  SET:  set: super setfPrect: self ;M
  103.  
  104.     :M  PORTBIT: ( -- abs) (abs) 2+ ;M
  105.  
  106.     \ update window with its entire port rectangle as the update region.
  107.     :M  UPDATE: pushPort set: self
  108.         getRect: self  put: tempRect  update: tempRect
  109.         popPort ;M
  110.  
  111.     :M InitNewWindow: setView: [ ^base ]
  112.         set: self initFont true put: alive cls ;M
  113.  
  114.     :M PenIntoWind: @xy bottom min gotoxy ;M
  115.  
  116.     \ Define a new window on heap with specified features
  117.     :M  NEW:  { bndsRect tAddr tLen procID vis goAway -- }
  118.         Get: Alive  0=
  119.         IF    0 (abs)  bndsrect +base  taddr tlen str255 vis bool
  120.             procID  makeInt inFront  goAway bool  0
  121.             call NewWindow drop   initNewWindow: self
  122.         THEN  ;M
  123.  
  124.     \ ( -- )  new window from resource file
  125.     :M  GETNEW:   get: alive  0=
  126.         IF  0 int: resid (abs) infront
  127.             call GetNewWindow 0= classerr" 170
  128.             initNewWindow: self select: [ ^base ] 
  129.         ELSE drop
  130.     THEN   ;M
  131.  
  132.     \ ( -- l t r b )  Return the vert. scroll bar rect
  133.     :M  GETVRECT:  GetBotx: portRect  15 -
  134.         GetTopy: portRect 1- getBotX: portRect 1+
  135.         getBotY: portRect 14 - ;M
  136.  
  137.     \ ( -- l t r b )  Return the horizontal scroll bar rect
  138.     :M  GETHRECT: getTopX: portRect 1- getBotY: portRect 15 -
  139.         getBotX: portRect 14 - getBotY: portRect 1+ ;M
  140.  
  141.     \ ( -- )  update content area
  142.     :M  DRAW:    get: fPrect
  143.         (abs) call BeginUpdate
  144.         savePort @xy set: self
  145.         get: growFlg
  146.         IF    @xy (abs)  call DrawGrowIcon
  147.             gotoxy
  148.         THEN
  149.         exec: draw   restport gotoxy    \ call user draw routine
  150.         (abs) call EndUpdate 
  151.         put: fPrect  ;M
  152.  
  153.     \ ( -- )  Make this the front window
  154.     :M  SELECT:   (abs)  call SelectWindow setfPrect: self ;M
  155.  
  156.     \ The idle: method is normally called, (after executing the system tasks),
  157.     \ for the front-most window, whenever a null event occurs. It should be a
  158.     \ window-specific task.  NULL-EVT is the normal word which sends idle:
  159.     :M  IDLE:    exec: idle ;M
  160.  
  161.     \ ( cfa -- )  Install a null event handler for this window
  162.     :M  SETIDLE: put: idle  ;M
  163.  
  164.     \ ( -- )  response to activate event
  165.     :M  ENABLE:  ^base -> actW                \ commence idle handler
  166.         set: self
  167.         get: growFlg IF @xy (abs) call DrawGrowIcon gotoxy THEN
  168.         exec: Enact  ;M
  169.  
  170.     \ ( -- )  response to deactivate event
  171.     :M  DISABLE: 0 -> actW
  172.         get: growFlg
  173.         IF @xy (abs) call DrawGrowIcon gotoxy THEN
  174.         exec: deact ;M   \ cease idle handler
  175.  
  176.     \ ( enact deact -- )  Set the activate/deactivate event handlers
  177.     :M  SETACT:  put: Deact put: Enact  ;M
  178.  
  179.     \ ( -- b )  is this window active ?
  180.     :M  ACTIVE:  0 call FrontWindow (abs)  =    ;M
  181.  
  182.     \ ( -- b )  is this window alive?
  183.     :M  ALIVE:   get: alive   ;M
  184.  
  185.     \ ( -- )  response to drag region click
  186.     :M  DRAG:  get: dragFlg
  187.         IF (abs)  Where: fEvent  abs: dragRect
  188.             call DragWindow
  189.         THEN  ;M
  190.  
  191.     :M ERASEGROW: get: growFlg
  192.         IF  getVRect: self 16 + put: tempRect
  193.             clear: tempRect update: tempRect
  194.             getHRect: self put: temprect clear: temprect  update: tempRect
  195.         THEN ;M
  196.  
  197.     :M FIXGROW: eraseGrow: self setView: [ ^base ] penIntoWind: self ;M
  198.  
  199.     \ ( w h -- )  reSize window and accumulate update regions
  200.     :M  SIZE:    pack  (abs)  swap  True makeInt
  201.         eraseGrow: self
  202.         call SizeWindow    \ resize the window
  203.         fixGrow: self    ;M
  204.  
  205.     :M  ZOOM: { part -- } word0 (abs) where: fEvent
  206.         part makeint call TrackBox i->l
  207.         IF     eraseGrow: self get: zoom
  208.             IF   part 7 - exec: zoom                        \ execute special zoom
  209.             ELSE (abs) part makeint word0 call zoomWindow    \ default zoom
  210.             THEN
  211.             fixGrow: self
  212.         THEN ;M
  213.  
  214.     \ ( -- )  response to grow region click
  215.     :M  GROW:  Get: growFlg
  216.         IF  0 (abs) Where: fEvent  abs: growrect
  217.             call GrowWindow  -dup
  218.             IF  unpack size: self draw: self
  219.                 penIntoWind: self    \ go to new bottom
  220.             THEN
  221.         THEN  (abs) call SelectWindow ;M
  222.  
  223.     \ ( -- )  Handle a content click
  224.     :M  CONTENT:  Active: self
  225.         IF    exec: content    \ call the content handler
  226.         ELSE  (abs) call SelectWindow THEN  ;M
  227.  
  228.     \ ( close enact draw cont -- )  init window  event handler words
  229.     :M  ACTIONS:   put: content  put: draw  put: enact
  230.         put: close  ;M
  231.  
  232.     \ ( addr len -- )
  233.     :M  TITLE:   str255 (abs) swap  call SetWTitle  ;M
  234.  
  235.     \ ( addr len -- )  Name: is for string class compatibility
  236.     :M  NAME:  title: self  ;M
  237.  
  238.     \ ( -- addr len )  return name of window
  239.     :M  GETNAME:  (abs)  buf255 +base call GetWTitle
  240.         buf255 count   ;M
  241.  
  242.     \ ( x y -- )
  243.     :M  MOVETO:   Pack (abs) swap false makeInt
  244.         call MoveWindow   ;M
  245.  
  246.     :M  CENTER: { \ sw sh pw ph -- }
  247.         screenBits -> sh -> sw 2drop
  248.         size: portRect -> ph -> pw
  249.         sw pw - 2/  sh ph - 2/  moveto: self ;M
  250.         
  251.     \ ( chr -- )  just drop keys
  252.     :M  KEY:   drop ;M
  253.  
  254.     \ ( -- )   Make this window visible
  255.     :M  SHOW:   (abs)  call ShowWindow ;M
  256.  
  257.     \ ( -- )   Make this window visible
  258.     :M  HIDE:   (abs)  call HideWindow ;M
  259.  
  260.     \ ( l t r b  t OR f -- )  set grow limits
  261.     :M  SETGROW:    DUP put: GrowFlg
  262.         IF  put: growrect THEN ;M
  263.  
  264.     \ ( l t r b  t OR f -- )  Set drag limits
  265.     :M  SETDRAG:  dup  Put: dragFlg
  266.         IF Put: dragRect THEN  ;M
  267.  
  268.     \ ( cfa -- )  set the draw handler
  269.     :M  SETDRAW:  put: draw  ;M
  270.  
  271.     :M  CLASSINIT:
  272.         <[ 4 ]> 'cfas  null null null null actions: self
  273.         'c null put: idle
  274.         'c null put: deact
  275.     ;M
  276.  
  277.     \ ( -- )  show an example of Window; use grayRgn for drag limits
  278.     :M EXAMPLE:  100 100 300 200 put: tempRect    \ set size of window
  279.         tempRect  " Example"
  280.         docWind  true true  new: self
  281.         grayRgn true setDrag: self  ;M
  282.  
  283. ;CLASS
  284.  
  285. ' Window 'c fWind !
  286.